; pattern match 程序


(defconstant fail nil "Indicates pat-match failure")

(defconstant no-bindings '((t . t)))


(defun pat-match (pattern input &optional (bindings no-bindings))
  (cond ((eq bindings fail) fail)
	((variable-p pattern)
	 (match-variable pattern input bindings))
	((eql pattern input) bindings)
	((segment-pattern-p pattern)
	 (segment-matcher pattern input bindings))
	((single-pattern-p pattern)
	 (single-matcher pattern input bindings))
	((and (consp pattern) (consp input))
	 (pat-match (rest pattern) (rest input)
		    (pat-match (first pattern) (first input) bindings)))
	(t fail)))

(defun variable-p (x)
  (and (symbolp x) (equal (char (symbol-name x) 0) #\?)))

(defun get-binding (var binding)
  (assoc var binding))

(defun binding-var (binding)
  (car binding))

(defun binding-val (binding)
  (cdr binding))

(defun make-binding (var val) (cons var val))

(defun lookup (var bindings)
  (binding-val (get-binding var bindings)))

(defun extend-bindings (var val bindings)
  (cons (make-binding var val)
	(if (eq bindings no-bindings)
	    nil
	    bindings)))

(defun match-variable (var input bindings)
  (let ((binding (get-binding var bindings)))
    (cond ((not binding) (extend-bindings var input bindings))
	  ((equal binding input) bindings)
	  (t fail))))

(setf (get '?is 'single-match) 'match-is)
(setf (get '?or 'single-match) 'match-or)
(setf (get '?and 'single-match) 'match-and)
(setf (get '?not 'single-match) 'match-not)

(setf (get '?* 'segment-match) 'segment-match)
(setf (get '?+ 'segment-match) 'segment-match+)
(setf (get '?? 'segment-match) 'segment-match?)
(setf (get '?if 'segment-match) 'match-if)



(defun match-is (var-and-pred input binding)
  (let* ((var (first var-and-pred))
	 (pred (second var-and-pred))
	 (new-bindings (pat-match var input binding)))
    (if (or (eq new-bindings fail)
	    (not (funcall pred input)))
	fail
	new-bindings)))

(defun match-and (patterns input bindings)
  (cond ((eq bindings fail) fail)
	((null patterns) bindings)
	(t (match-and (rest patterns) input
		      (pat-match (first patterns) input bindings)))))


(defun match-or (patterns input bindings)
  (if (null patterns)
      fail
      (let ((new-bindings (pat-match (first patterns) input bindings)))
	(if (eq new-bindings fail)
	    (match-or (rest patterns) input bindings)
	    new-bindings))))


(defun match-not (patterns input bindings)
  (if (match-or patterns input bindings)
      fail
      bindings))


(defun segment-match (pattern input bindings &optional (start 0))
  (let ((var (second (first pattern)))
	(pat (rest pattern)))
    (if (null pat)
	(match-variable var input bindings)
	(let ((pos (first-match-pos (first pat) input start)))
	  (if (null pos)
	      fail
	      (let ((b2 (pat-match
			pat (subseq input pos)
			(match-variable var (subseq input 0 pos) bindings))))
		(if (eq b2 fail)
		    (segment-match pattern input bindings (+ pos 1))
		    b2)))))))


(defun first-match-pos (pattern input start)
  (cond ((and (atom pattern) (not (variable-p pattern)))
	 (position pattern input :start start :test #'equal))
	((< start (length input)) start)
	(t nil)))


(defun segment-pattern-p (pattern)
  (and (consp pattern)
       (consp (first pattern))
       (symbolp (first (first pattern)))
       (segment-match-fn (first (first pattern)))))


(defun segment-match-fn (x)
  (when (symbolp x) (get x 'segment-match)))

(defun single-pattern-p (pattern)
  (and (consp pattern)
       (single-match-fn (first pattern))))

(defun single-matcher (pattern input bindings)
  (funcall (single-match-fn (first pattern))
	   (rest pattern) input bindings))


(defun single-match-fn (x)
  (when (symbolp x) (get x 'single-match)))


(defun segment-matcher (pattern input bindings)
  (funcall (segment-match-fn (first (first pattern)))
	   pattern input bindings))
			    

(defun pat-match-abbrev (symbol expansion)
  (setf (get symbol 'expand-pat-match-abbrev)
	(expand-pat-match-abbrev expansion)))


(defun expand-pat-match-abbrev (pat)
  (cond ((and (symbolp pat) (get pat 'expand-pat-match-abbrev)))
	((atom pat) pat)
	(t
	 (cons (expand-pat-match-abbrev (first pat))
	       (expand-pat-match-abbrev (rest pat))))))


(defun unify (x y &optional (bindings no-bindings))
  "See if x and y match with given bindings"
  (cond ((eq bindings fail) fail)
	((eql x y) bindings)
	((variable-p x) (unify-variable x y bindings))
	((variable-p y) (unify-variable y x bindings))
	((and (consp x) (consp y))
	 (unify (rest x) (rest y)
		(unify (first x) (first y) bindings)))
	(t fail)))


(defun unify-variable (var x bindings)
  (if (get-binding var bindings)
      (unify (lookup var bindings) x bindings)
      (extend-bindings var x bindings)))